;;############################################################################
;; datavis4.lsp                             (continues code in datavis3.lsp)
;; Copyright (c) 1999-2000 by Forrest W. Young
;; code to support visualization of n-way frequency array data (category data)
;; and crosstabs data (category plus multivariate numeric)
;; all methods in this file used by both category and crosstabs visualizations
;;############################################################################



;ALSO USED BY CROSSTABS
(defmeth mv-data-object-proto :add-vnfa-varlist-features (way-list nvar sp)
  (when (not (send self :has-slot 'plot-help)) 
        (send self :add-slot 'plot-help)
        (defmeth self :plot-help (&optional (val nil set))
            (if set (setf (slot-value 'plot-help) val))
            (slot-value 'plot-help)))
  (let ((dob self))
    (defmeth way-list :plot-help ()
      (plot-help-window (strcat "Help for Category Variables"))
      (paste-plot-help (format nil "This window lists and lets you select the category variables. Selected variables are those that are high-lighted. The selected category variables are used to form the frequency crosstabulation that is shown in the table and in the mostaic plot and bargraph. You can select up to four variables.~2%")) 
      (paste-plot-help (format nil "You select a variable by clicking on its name. You can select several variables by dragging your mouse across them while holding the button down, or by control-clicking each variable."))
      (show-plot-help))
    (defmeth way-list :do-select-click (x y m1 m2)
      (when (not (send self :has-slot 'old-var-list))
            (send self :add-slot 'old-var-list)
            (defmeth self :old-var-list (&optional (avar-list nil set))
              (if set (setf (slot-value 'old-var-list) avar-list))
              (slot-value 'old-var-list)))
      (call-next-method x y m1 m2)
      (let* ((cur-var  (send self :selection))
             (old-var (send self :old-var-list))
             (nvar nil) (variable-labels nil)
             (var-labs nil) (cur-data nil) )
        (when cur-var
              (when (and m1 (send self :old-var-list))
                    (mapcar 
                     #'(lambda (i) 
                         (setf cur-var 
                               (remove (select old-var i) cur-var)))
                     (iseq (length old-var)))
                    (setf cur-var (combine old-var cur-var )) )
              (send self :old-var-list cur-var)
              (setf nvar (send self :num-points))
              (setf variable-labels 
                    (send self :point-label (iseq nvar)))
              (setf var-labs (select variable-labels cur-var))
             ; (setf cur-data 
             ;       (map-elements #'send dob :variable var-labs))
            (send sp :update-spreadplot 0 2  cur-var T)
              (send self :show-window)))))
  (send way-list :fix-name-list)
  (send way-list :use-color t)
  (send way-list :point-color (iseq nvar) 'red)
  (send way-list :redraw))
   

(defmeth mv-data-object-proto :sum-freq-arrays (indices crosstab)
"Takes the frequencies in an n-way freq-array and converts it into a matrix whose rows and columns correspond to INDICES. The elements of the matrix are frequencies summed over the remaining ways. If the n-way array is 1-way, the matrix has 1 row and several columns.  If there is also an n-way data-array it is collapsed into a matrix whose elements are the appropriate data (which may be multivariate). Returns the matrix of summed frequencies, or a list of the summed frequencies matrix and the reorganized data matrix." 
  (let* ((freq-array (send self :freq-array))
         (data-array (send self :data-array))
         (sizes (array-dimensions freq-array))
         (rank (array-rank freq-array))
;array-list returns same info regardless of order of indices - use permute-array 
         (permutation-indices (remove 'nil
          (combine indices 
                   (sort-data (set-difference (iseq rank) indices)))))
;compute summed freq matrix
         (permuted-freq-array (permute-array freq-array permutation-indices))
         (freq-list (array-list permuted-freq-array (iseq (length indices))))
         (summat (apply #'+ freq-list))
         (permuted-data-array) (permuted-sizes) (data-array-sizes)
         (data-3way-array) (data-matrix) (n-indices (length indices))
         )
;when appropriate, compute collapsed data matrix
    (when crosstab
    (unless (send self :has-slot 'nways-of-table)
            (send self :add-slot 'nways-of-table))
    (send self :slot-value 'nways-of-table indices)
    (when data-array

          (setf permuted-sizes (select sizes permutation-indices))
          (setf data-array-sizes 
                (cond
                  ((> rank 3)
                   (combine (select permuted-sizes (iseq n-indices))
                            (prod (select permuted-sizes (iseq n-indices (1- rank))))))
                  ((= rank 3) permuted-sizes)
                  ((= rank 2) (combine permuted-sizes 1))
                  ((= rank 1) (combine 1 permuted-sizes 1))))

          (case n-indices
            (1 (setf scrambled-indices (select indices '(0))))
            (2 (setf scrambled-indices (select indices '(1 0))))
            (3 (setf scrambled-indices (select indices '(1 0 2))));1 0 2
            (4 (setf scrambled-indices (select indices '(1 3 0 2)))));1 3 0 2

          (setf (select permutation-indices (iseq n-indices)) scrambled-indices)
          (SETF PERMUTATION-INDICES (COERCE PERMUTATION-INDICES 'LIST))
         
          (setf permuted-data-array (permute-array data-array permutation-indices))
          (case n-indices
            (1 (setf data-array-sizes (combine 1 (select data-array-sizes 0) 
                                               (select data-array-sizes 1)
                                             ; (prod (select data-array-sizes '(1 2)))
                                               )))
            (2
             (setf data-array-sizes 
                   (select data-array-sizes '(1 0 2))))
            (3
             (setf data-array-sizes 
                   (list (select data-array-sizes 1)
                         (prod (select data-array-sizes '(0 2)))
                         (select data-array-sizes 3))))
            (4 
             (setf data-array-sizes 
                   (list (prod (select data-array-sizes '(1 3)))
                         (prod (select data-array-sizes '(0 2)))
                         (select data-array-sizes 4)))))
          (setf data-3way-array 
                (make-array data-array-sizes :displaced-to permuted-data-array))
          (setf data-matrix (make-array (select data-array-sizes '(0 1))))
          (dotimes (i (first data-array-sizes))
             (dotimes  (j (second data-array-sizes))
                (setf (aref data-matrix i j) (remove-if 'null (combine 
                  (select data-3way-array  i j  (iseq (third data-array-sizes))))))))
           ))
    (if crosstab (list summat data-matrix) summat)))


;see expected-values function in functin2.lsp

(defmeth mv-data-object-proto :expected-values (freq-array)
"Args: freq-array
Calculated expected frequencies for cells of an n-way frequency array. Returns a list with two elements. The first element is the n-way array of expected frequencies. The second is a list of lists of marginal proportions, one list for each way of the array."
  (expected-values freq-array))

(defun nested-prod (indices prod marginal-props sizes array)
"Recursively calculates the expected value for every cell of an array."
  (cond
    ((> (length sizes) 0)
     (dotimes (i (first sizes))
              (nested-prod (combine indices i)
                           (* prod (select (first marginal-props) i))
                           (rest marginal-props)
                           (rest sizes)
                           array)))
    (t (setf (apply #'aref array indices) prod))))
  
       

(defmeth mv-data-object-proto :make-bordered-freq-datalist
         (obs-labels variables freq-mat)
"Args: obs-labels variables freq-mat
Borders a frequency matrix with row/col/grand sums. obslabels and variables are strings naming obs and vars."
  (let* ((row-sums (apply #'+ (column-list freq-mat)))
         (col-sums (apply #'+ (row-list freq-mat)))
         (grand-sum (sum col-sums))
         (sizes (array-dimensions freq-mat))
         (obslist obs-labels)
         (varlist variables)
    )
    (when (> (second sizes) 1)
          (setf varlist (combine varlist "RowSum"))
          (setf freq-mat (bind-columns freq-mat row-sums)))
    (when (> (first sizes) 1)
          (setf freq-mat (bind-rows freq-mat 
                                    (combine col-sums grand-sum)))
          (setf obslist (combine obslist "ColSum")))
    (list obslist varlist (combine freq-mat))))
  
(defmeth mv-data-object-proto :make-bordered-freq-matrix
         (classes nclasses freq-mat)
"Args: classes nclasses freq-info
Borders a frequency matrix with row/col/grand sums. nclasses specifies number of classes/levels for each way of the array. classes is a list of lists of class/level name strings"
  (let* ((row-sums (apply #'+ (column-list freq-mat)))
         (col-sums (apply #'+ (row-list freq-mat)))
         (grand-sum (sum col-sums))
         (freq-mat (bind-rows (bind-columns freq-mat row-sums) 
                                 (combine col-sums grand-sum)))
         (obslist (combine (first classes) "ColSum"))
         (varlist (combine (second classes) "RowSum"))
         )
    (list freq-mat obslist varlist)))

(defmeth mv-data-object-proto :make-spreadplot-freq-array
         (classes nclasses freq-info &optional (borders t))
"Args: classes nclasses freq-info &optional (borders t)
Converts n-way arrays into 2-way arrays with borders of row/col sums, unless borders is nil (t by default). Freq-info may be an array or a list of elements of an array. nclasses specifies number of classes/levels for each way of the array. classes is a list of lists of class/level name strings. "
  (let* ((freq-mat (if (listp freq-info)
                       (make-array nclasses :initial-contents freq-info)
                       freq-info))
         (nways (length nclasses))
         (freq-mat (if (= nways 1)
                       (make-array (list 1 (first nclasses))
                                   :displaced-to freq-mat)
                       (make-array (list (first nclasses)
                                         (sum (rest nclasses)))
                                   :displaced-to freq-mat)))
         (obslist) (varlist) (row-sums) (col-sums) (grand-sum)
         )
    (when borders
          (setf row-sums (apply #'+ (column-list freq-mat)))
          (setf col-sums (apply #'+ (row-list freq-mat)))
          (setf grand-sum (sum col-sums))
          )
    (cond 
      ((= nways 1)
       (when borders (setf freq-mat (bind-columns freq-mat row-sums)))
       (setf obslist (list "Totals"))
       (if borders (setf varlist (combine (first classes) "Grand Sum"))
           (setf varlist (first classes))))
      ((= (select nclasses 0) 1)
       (when borders (setf freq-mat (bind-columns freq-mat grand-sum)))
       (setf obslist (first classes))
       (if borders (setf varlist (combine (second classes) "Grand Sum"))
           (setf varlist (second classes))))
      ((= (select nclasses 1) 1)
       (when borders (setf freq-mat (bind-rows freq-mat grand-sum)))
       (if borders (setf obslist (combine (first classes) "Grand Sum"))
           (setf obslist (first classes))) 
       (setf varlist (second classes)))
      (t
       (cond
         (borders (setf freq-mat (bind-rows (bind-columns freq-mat row-sums) 
                                            (combine col-sums grand-sum)))
                  (setf obslist (combine (first classes) "Col Sums"))
                  (setf varlist (combine (second classes) "Row Sums")))
         (t (setf obslist (first classes))
            (setf varlist (second classes))))))
    (setf cellfreqs (combine (row-list freq-mat)))
    (list cellfreqs obslist varlist)))

